home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 2 / Amiga Tools 2.iso / tools / jade / lisp / compiler.jl < prev    next >
Lisp/Scheme  |  1995-03-09  |  36KB  |  1,068 lines
  1. ;;;; compiler.jl -- Simple compiler for Lisp files/forms
  2. ;;;  Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. ;;; This file is part of Jade.
  5.  
  6. ;;; Jade is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2, or (at your option)
  9. ;;; any later version.
  10.  
  11. ;;; Jade is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15.  
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Jade; see the file COPYING.  If not, write to
  18. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20.  
  21. ;;; Notes:
  22. ;;;
  23. ;;; Instruction Encoding
  24. ;;; ====================
  25. ;;; Instructions which get an argument (with opcodes of zero up to
  26. ;;; `op-last-with-args') encode the type of argument in the low 3 bits
  27. ;;; of their opcode (this is why these instructions take up 8 opcodes).
  28. ;;; A value of 0 to 5 (inclusive) is the literal argument, value of
  29. ;;; 6 means the next byte holds the argument, or a value of 7 says
  30. ;;; that the next two bytes are used to encode the argument (in big-
  31. ;;; endian form, i.e. first extra byte has the high 8 bits)
  32. ;;;
  33. ;;; All instructions greater than the `op-last-before-jmps' are branches,
  34. ;;; currently only absolute destinations are supported, all branch
  35. ;;; instructions encode their destination in the following two bytes (also
  36. ;;; in big-endian form).
  37. ;;;
  38. ;;; Any opcode between `op-last-with-args' and `op-last-before-jmps' is
  39. ;;; a straightforward single-byte instruction.
  40. ;;;
  41. ;;; The machine simulated by lispmach.c is a simple stack-machine, each
  42. ;;; call to the byte-code interpreter gets its own stack; the size of
  43. ;;; stack needed is calculated by the compiler.
  44. ;;;
  45. ;;; If you hadn't already noticed I based this on the Emacs version 18
  46. ;;; byte-compiler.
  47. ;;;
  48. ;;; Constants
  49. ;;; =========
  50. ;;; `defconst' forms have to be used with some care. The compiler assumes
  51. ;;; that the value of the constant is always the same, whenever it is
  52. ;;; evaluated. It may even be evaluated more than once.
  53. ;;;
  54. ;;; In general, any symbols declared as constants (by defconst) have their
  55. ;;; values set in stone. These values are hard-coded into the compiled
  56. ;;; byte-code.
  57. ;;;
  58. ;;; Also, the value of a constant-symbol is *not* likely to be eq to itself!
  59. ;;;
  60. ;;; Use constants as you would use macros in C, i.e. to define values which
  61. ;;; have to be the same throughout a module. For example, this compiler uses
  62. ;;; defconst forms to declare the instruction opcodes.
  63. ;;;
  64. ;;; If you have doubts about whether or not to use constants -- don't; it may
  65. ;;; lead to subtle bugs.
  66.  
  67.  
  68. (provide 'compiler)
  69.  
  70.  
  71. ;; Options
  72. (defvar comp-write-docs nil
  73.   "When t all doc-strings are appended to the doc file and replaced with
  74. their position in that file.")
  75.  
  76.  
  77. ;; Opcodes
  78. (defconst op-call 0x08)            ;call (stk[n] stk[n-1] ... stk[0])
  79.                     ; pops n values, replacing the
  80.                     ; function with the result.
  81. (defconst op-push 0x10)            ;pushes constant # n
  82. (defconst op-vrefc 0x18)        ;pushes val of symbol n (in c-v)
  83. (defconst op-vsetc 0x20)        ;sets symbol n (in c-v) to stk[0],
  84.                     ; then pops the stack.
  85. (defconst op-list 0x28)            ;makes top n items into a list
  86. (defconst op-bind 0x30)            ;bind constant n to stk[0], pops stk
  87.  
  88. (defconst op-last-with-args 0x37)
  89.  
  90. (defconst op-vref 0x40)            ;replace symbol with it's value
  91. (defconst op-vset 0x41)            ;set (sym)stk[0]=stk[1], pops both
  92. (defconst op-fref 0x42)            ;similar to vref/vset, but for
  93. (defconst op-fset 0x43)            ; function value.
  94. (defconst op-init-bind 0x44)        ;initialise a new set of bindings
  95. (defconst op-unbind 0x45)        ;unbind all bindings in the top set
  96. (defconst op-dup 0x46)            ;duplicate top of stack
  97. (defconst op-swap 0x47)            ;swap top two values on stack
  98. (defconst op-pop 0x48)            ;pops the stack
  99.  
  100. (defconst op-nil 0x49)            ;pushes nil
  101. (defconst op-t 0x4a)            ;pushes t
  102. (defconst op-cons 0x4b)
  103. (defconst op-car 0x4c)
  104. (defconst op-cdr 0x4d)
  105. (defconst op-rplaca 0x4e)
  106. (defconst op-rplacd 0x4f)
  107. (defconst op-nth 0x50)
  108. (defconst op-nthcdr 0x51)
  109. (defconst op-aset 0x52)
  110. (defconst op-aref 0x53)
  111. (defconst op-length 0x54)
  112. (defconst op-eval 0x55)
  113. (defconst op-plus-2 0x56)        ;The `-2' on the end means that it
  114. (defconst op-negate 0x57)        ; only works on 2 arguments.
  115. (defconst op-minus-2 0x58)
  116. (defconst op-product-2 0x59)
  117. (defconst op-divide-2 0x5a)
  118. (defconst op-mod-2 0x5b)
  119. (defconst op-lognot 0x5c)
  120. (defconst op-not 0x5d)
  121. (defconst op-logior-2 0x5e)
  122. (defconst op-logand-2 0x5f)
  123. (defconst op-equal 0x60)
  124. (defconst op-eq 0x61)
  125. (defconst op-num-eq 0x62)
  126. (defconst op-num-noteq 0x63)
  127. (defconst op-gtthan 0x64)
  128. (defconst op-gethan 0x65)
  129. (defconst op-ltthan 0x66)
  130. (defconst op-lethan 0x67)
  131. (defconst op-inc 0x68)
  132. (defconst op-dec 0x69)
  133. (defconst op-lsh 0x6a)
  134. (defconst op-zerop 0x6b)
  135. (defconst op-null 0x6c)
  136. (defconst op-atom 0x6d)
  137. (defconst op-consp 0x6e)
  138. (defconst op-listp 0x6f)
  139. (defconst op-numberp 0x70)
  140. (defconst op-stringp 0x71)
  141. (defconst op-vectorp 0x72)
  142. (defconst op-catch-kludge 0x73)
  143. (defconst op-throw 0x74)
  144. (defconst op-unwind-pro 0x75)
  145. (defconst op-un-unwind-pro 0x76)
  146. (defconst op-fboundp 0x77)
  147. (defconst op-boundp 0x78)
  148. (defconst op-symbolp 0x79)
  149. (defconst op-get 0x7a)
  150. (defconst op-put 0x7b)
  151. (defconst op-error-pro 0x7c)
  152. (defconst op-signal 0x7d)
  153. (defconst op-return 0x7e)
  154. (defconst op-reverse 0x7f)        ;new 12/7/94
  155. (defconst op-nreverse 0x80)
  156. (defconst op-assoc 0x81)
  157. (defconst op-assq 0x82)
  158. (defconst op-rassoc 0x83)
  159. (defconst op-rassq 0x84)
  160. (defconst op-last 0x85)
  161. (defconst op-mapcar 0x86)
  162. (defconst op-mapc 0x87)
  163. (defconst op-member 0x88)
  164. (defconst op-memq 0x89)
  165. (defconst op-delete 0x8a)
  166. (defconst op-delq 0x8b)
  167. (defconst op-delete-if 0x8c)
  168. (defconst op-delete-if-not 0x8d)
  169. (defconst op-copy-sequence 0x8e)
  170. (defconst op-sequencep 0x8f)
  171. (defconst op-functionp 0x90)
  172. (defconst op-special-form-p 0x91)
  173. (defconst op-subrp 0x92)
  174. (defconst op-eql 0x93)
  175. (defconst op-logxor-2 0x94)        ;new 23-8-94
  176.  
  177. (defconst op-set-current-buffer 0xb0)
  178. (defconst op-swap-buffer 0xb1)        ;switch to buffer stk[0], stk[0]
  179.                     ; becomes old buffer.
  180. (defconst op-current-buffer 0xb2)
  181. (defconst op-bufferp 0xb3)
  182. (defconst op-markp 0xb4)
  183. (defconst op-windowp 0xb5)
  184. (defconst op-swap-window 0xb6)
  185.  
  186. (defconst op-last-before-jmps 0xfa)
  187.  
  188. ;; All jmps take two-byte arguments
  189. (defconst op-jmp 0xfb)            ;jmp to x
  190. (defconst op-jn 0xfc)            ;pop the stack, if nil, jmp x
  191. (defconst op-jt 0xfd)            ;pop the stack, if t, jmp x
  192. (defconst op-jnp 0xfe)            ;if stk[0] nil, jmp x, else pop
  193. (defconst op-jtp 0xff)            ;if stk[0] t, jmp x, else pop
  194.  
  195. (defconst comp-max-1-byte-arg 5)    ;max arg held in 1-byte instruction
  196. (defconst comp-max-2-byte-arg 0xff)    ;max arg held in 2-byte instruction
  197. (defconst comp-max-3-byte-arg 0xffff)    ;max arg help in 3-byte instruction
  198.  
  199.  
  200. ;; Environment of this byte code sequence being compiled
  201.  
  202. (defvar comp-constant-alist '())    ;list of (VALUE . INDEX)
  203. (defvar comp-constant-index 0)        ;next free constant index number
  204. (defvar comp-current-stack 0)        ;current stack requirement
  205. (defvar comp-max-stack 0)        ;highest possible stack
  206. (defvar comp-output nil)        ;list of (BYTE . INDEX)
  207. (defvar comp-output-pc 0)        ;INDEX of next byte
  208. (defvar comp-macro-env '())        ;alist of (NAME . MACRO-DEF)
  209. (defvar comp-const-env '())        ;alist of (NAME . CONST-DEF)
  210.  
  211.  
  212. (defvar comp-top-level-compiled
  213.   '(if cond when unless let let* catch unwind-protect error-protect
  214.     with-buffer with-window progn prog1 prog2 while and or)
  215.   "List of symbols, when the name of the function called by a top-level form
  216. is one of these that form is compiled.")
  217.  
  218. ;;;###autoload
  219. (defun compile-file (file-name)
  220.   "Compiles the file of jade-lisp code FILE-NAME into a new file called
  221. `(concat FILE-NAME ?c)' (ie, `foo.jl' => `foo.jlc')."
  222.   (interactive "fLisp file to compile:")
  223.   (let
  224.       (src-file dst-file form
  225.        comp-macro-env
  226.        comp-const-env)
  227.     (when (and (setq src-file (open file-name "r"))
  228.            (setq dst-file (open (concat file-name ?c) "w")))
  229.       (format dst-file
  230.           ";;; Source file: %s\n;;; Compiled by %s@%s on %s\n;;; Jade %d.%d\n"
  231.           file-name (user-login-name) (system-name) (current-time-string)
  232.           (major-version-number) (minor-version-number))
  233.       (error-protect
  234.         (unwind-protect
  235.         (let
  236.         (form)
  237.           (message (concat "Compiling " file-name "...") t)
  238.           (while (not (file-eof-p src-file))
  239.         (when (setq form (read src-file))
  240.           (cond
  241.            ((memq (car form) '(defun defmacro defvar defconst require))
  242.             (setq form (comp-compile-top-form form)))
  243.            ((memq (car form) comp-top-level-compiled)
  244.             ;; Compile this form
  245.             (setq form (compile-form form))))
  246.           (when form
  247.             (print form dst-file)
  248.             (write dst-file ?\n)))))
  249.       (close dst-file)
  250.       (close src-file))
  251.     (error
  252.       ;; Be sure to remove any partially written dst-file. Also, signal
  253.       ;; the error again so that the user sees it.
  254.       (let
  255.           ((fname (concat file-name ?c)))
  256.         (when (file-exists-p fname)
  257.           (delete-file fname)))
  258.       ;; Hack to signal error without entering the debugger (again)
  259.       (throw 'error error-info)))
  260.       t)))
  261.  
  262. ;;;###autoload
  263. (defun compile-directory (dir-name &optional force-p exclude-list)
  264.   "Compiles all jade-lisp files in the directory DIRECTORY-NAME whose object
  265. files are either older than their source file or don't exist. If FORCE-P
  266. is non-nil every lisp file is recompiled.
  267. EXCLUDE-LIST is a list of files which shouldn't be compiled."
  268.   (interactive "DDirectory of Lisp files to compile:\nP")
  269.   (let
  270.       ((dir (directory-files dir-name)))
  271.     (while (consp dir)
  272.       (when (and (regexp-match "\\.jl$" (car dir))
  273.          (null (member (car dir) exclude-list)))
  274.     (let*
  275.         ((file (file-name-concat dir-name (car dir)))
  276.          (cfile (concat file ?c)))
  277.       (when (file-newer-than-file-p file cfile)
  278.         (compile-file file))))
  279.       (setq dir (cdr dir)))
  280.     t))
  281.  
  282. (defvar compile-lib-exclude-list
  283.   '("autoload.jl"))
  284.  
  285. ;;;###autoload
  286. (defun compile-lisp-lib (&optional force-p)
  287.   "Recompile all out of date files in the lisp library directory. If FORCE-P
  288. is non-nil it's as though all files were out of date.
  289. This makes sure that all doc strings are written to their special file and
  290. that files which shouldn't be compiled aren't."
  291.   (interactive "P")
  292.   (let
  293.       ((comp-write-docs t))
  294.     (compile-directory lisp-lib-dir force-p compile-lib-exclude-list)))
  295.  
  296.  
  297. (put 'compile-error 'error-message "Compilation mishap")
  298. (defun comp-error (&rest data)
  299.   (signal 'compile-error data))
  300.  
  301. ;; Compile a form which occurred at the `top-level' into a byte code form.
  302. ;; defuns, defmacros, defvars, etc... are treated specially.
  303. ;; require forms are evaluated before being output uncompiled; this is so
  304. ;; any macros are brought in before they're used.
  305. (defun comp-compile-top-form (form)
  306.   (let
  307.       ((fun (car form)))
  308.     (cond
  309.      ((eq fun 'defun)
  310.       (let
  311.       ((tmp (assq (nth 1 form) comp-macro-env)))
  312.     (when tmp
  313.       (rplaca tmp nil)
  314.       (rplacd tmp nil)))
  315.       (cons 'defun
  316.         (cons (nth 1 form)
  317.           (cdr (comp-compile-lambda (cons 'lambda (nthcdr 2 form)))))))
  318.      ((eq fun 'defmacro)
  319.       (let
  320.       ((code (comp-compile-lambda (cons 'lambda (nthcdr 2 form))))
  321.        (tmp (assq (nth 1 form) comp-macro-env)))
  322.     (if tmp
  323.         (rplacd tmp code)
  324.       (setq comp-macro-env (cons (cons (nth 1 form) code) comp-macro-env)))
  325.     (cons 'defmacro (cons (nth 1 form) (cdr code)))))
  326.      ((eq fun 'defconst)
  327.       (let
  328.       ((value (eval (nth 2 form)))
  329.        (doc (nth 3 form)))
  330.     (when (and comp-write-docs (stringp doc))
  331.       (rplaca (nthcdr 3 form) (add-doc-string doc)))
  332.     (setq comp-const-env (cons (cons (nth 1 form) value) comp-const-env)))
  333.       form)
  334.      ((eq fun 'defvar)
  335.       (let
  336.       ((doc (nth 3 form)))
  337.     (when (and comp-write-docs (stringp doc))
  338.       (rplaca (nthcdr 3 form) (add-doc-string doc))))
  339.       form)
  340.      ((eq fun 'require)
  341.       (eval form)
  342.       form)
  343.      (t
  344.       (comp-error "Shouldn't have got here!")))))
  345.  
  346. ;;;###autoload
  347. (defun compile-form (form)
  348.   "Compile the Lisp form FORM into a byte code form."
  349.   (let
  350.       (comp-constant-alist
  351.        (comp-constant-index 0)
  352.        (comp-current-stack 0)
  353.        (comp-max-stack 0)
  354.        comp-output
  355.        (comp-output-pc 0))
  356.     (comp-compile-form form)
  357.     (when comp-output
  358.       (list 'jade-byte-code (comp-make-code-string) (comp-make-const-vec)
  359.         comp-max-stack))))
  360.  
  361. ;; Turn the alist of byte codes into a string
  362. (defun comp-make-code-string ()
  363.   (let
  364.       ((code-string (make-string comp-output-pc ?*))
  365.        (data comp-output))
  366.     (while (consp data)
  367.       (aset code-string (cdr (car data)) (car (car data)))
  368.       (setq data (cdr data)))
  369.     code-string))
  370.  
  371. ;; Turn the alist of constants into a vector
  372. (defun comp-make-const-vec ()
  373.   (let
  374.       ((vec (make-vector comp-constant-index))
  375.        (consts comp-constant-alist))
  376.     (while (consp consts)
  377.       (aset vec (cdr (car consts)) (car (car consts)))
  378.       (setq consts (cdr consts)))
  379.     vec))
  380.  
  381. ;; Increment the current stack size, setting the maximum stack size if
  382. ;; necessary
  383. (defun comp-inc-stack ()
  384.   (when (> (setq comp-current-stack (1+ comp-current-stack)) comp-max-stack)
  385.     (setq comp-max-stack comp-current-stack)))
  386.  
  387. ;; Decrement the current stack usage
  388. (defmacro comp-dec-stack (&optional n)
  389.   (list 'setq 'comp-current-stack 
  390.     (if n
  391.         (list '- 'comp-current-stack n)
  392.       (list '1- 'comp-current-stack))))
  393.  
  394. ;; Compile one form so that its value ends up on the stack when interpreted
  395. (defun comp-compile-form (form)
  396.   (cond
  397.     ((eq form nil)
  398.       (comp-write-op op-nil)
  399.       (comp-inc-stack))
  400.     ((eq form t)
  401.       (comp-write-op op-t)
  402.       (comp-inc-stack))
  403.     ((symbolp form)
  404.      (let
  405.      (val)
  406.        (cond
  407.     ((const-variable-p form)
  408.      ;; A constant already interned
  409.      (comp-write-op op-push (comp-add-constant (symbol-value form)))
  410.      (comp-inc-stack))
  411.     ((setq val (assq form comp-const-env))
  412.      ;; A constant from this file
  413.      (comp-compile-form (cdr val)))
  414.     (t
  415.      ;; Not a constant
  416.      (comp-write-op op-vrefc (comp-add-constant form))
  417.      (comp-inc-stack)))))
  418.     ((consp form)
  419.       (let
  420.       (fun)
  421.     (if (and (symbolp (car form)) (setq fun (get (car form) 'compile-fun)))
  422.         (funcall fun form)
  423.       (setq form (macroexpand form comp-macro-env))
  424.       (if (and (symbolp (car form))
  425.            (setq fun (get (car form) 'compile-fun)))
  426.           (funcall fun form)
  427.         (setq fun (car form))
  428.         (cond
  429.          ((symbolp fun)
  430.           (comp-compile-constant fun))
  431.          ((and (consp fun) (eq (car fun) 'lambda))
  432.           (comp-compile-constant (comp-compile-lambda fun)))
  433.          (t
  434.           (comp-error "Bad function name" fun)))
  435.         (setq form (cdr form))
  436.         (let
  437.         ((i 0))
  438.           (while (consp form)
  439.         (comp-compile-form (car form))
  440.         (setq i (1+ i)
  441.               form (cdr form)))
  442.           (comp-write-op op-call i)
  443.           (comp-dec-stack i))))))
  444.     (t
  445.       (comp-compile-constant form))))
  446.  
  447. ;; Push a constant onto the stack
  448. (defun comp-compile-constant (form)
  449.   (comp-write-op op-push (comp-add-constant form))
  450.   (comp-inc-stack))
  451.  
  452. ;; Put a constant into the alist of constants, returning its index number.
  453. ;; It won't be added twice if it's already there.
  454. (defun comp-add-constant (const)
  455.   (unless (cdr (assoc const comp-constant-alist))
  456.     (setq comp-constant-alist (cons (cons const comp-constant-index)
  457.                     comp-constant-alist)
  458.       comp-constant-index (1+ comp-constant-index))
  459.     (1- comp-constant-index)))
  460.  
  461. ;; Compile a list of forms, the last form's evaluated value is left on
  462. ;; the stack. If the list is empty nil is pushed.
  463. (defun comp-compile-body (body)
  464.   (if (null body)
  465.       (progn
  466.     (comp-write-op op-nil)
  467.     (comp-inc-stack))
  468.     (while (consp body)
  469.       (comp-compile-form (car body))
  470.       (when (cdr body)
  471.     (comp-write-op op-pop)
  472.     (comp-dec-stack))
  473.       (setq body (cdr body)))))
  474.  
  475. ;; From LIST, `(lambda (ARGS) [DOC-STRING] BODY ...)' returns a new list of,
  476. ;; `(lambda (ARGS) [DOC-STRING] (jade-byte-code ...))'
  477. (defun comp-compile-lambda (list)
  478.   (let
  479.       ((body (nthcdr 2 list))
  480.        new-head)
  481.     (cond
  482.       ((stringp (car body))
  483.     (setq body (cdr body)
  484.           new-head (list 'lambda (nth 1 list)
  485.                  (if comp-write-docs
  486.                  (add-doc-string (nth 2 list))
  487.                    (nth 2 list)))))
  488.       (t
  489.     (setq new-head (list 'lambda (nth 1 list)))))
  490.     ;; Check for an `(interactive ...)' declaration; it doesn't get compiled
  491.     (when (eq (car (car body)) 'interactive)
  492.       (setq new-head (nconc new-head (list (car body)))
  493.         body (cdr body)))
  494.     (nconc new-head (cons (compile-form (cons 'progn body)) nil))))
  495.  
  496.  
  497. ;; Managing the output code
  498.  
  499. ;; Return a new label
  500. (defmacro comp-make-label ()
  501.   ;; a label is, (PC-OF-LABEL . (LIST-OF-REFERENCES))
  502.   '(cons nil nil))
  503.  
  504. ;; Output a branch instruction to the label LABEL, if LABEL has not been
  505. ;; located yet this branch is recorded for later backpatching.
  506. (defun comp-compile-jmp (opcode label)
  507.   (comp-byte-out opcode)
  508.   (cond
  509.     ((numberp (car label))
  510.       ;; we know the final offset of this label so use it
  511.       (comp-byte-out (lsh (car label) -8))
  512.       (comp-byte-out (logand (car label) 0xff)))
  513.     (t
  514.       ;; offset unknown, show we need it patched in later
  515.       (rplacd label (cons comp-output-pc (cdr label)))
  516.       (setq comp-output-pc (+ comp-output-pc 2)))))
  517.  
  518. ;; Set the address of the label LABEL, any references to it are patched
  519. ;; with its address.
  520. (defun comp-set-label (label)
  521.   (when (> comp-output-pc comp-max-3-byte-arg)
  522.     (comp-error "Jump destination overflow!"))
  523.   (rplaca label comp-output-pc)
  524.   (setq label (cdr label))
  525.   (while (consp label)
  526.     (setq comp-output (cons (cons (lsh comp-output-pc -8) (car label))
  527.                 (cons (cons (logand comp-output-pc 0xff)
  528.                     (1+ (car label)))
  529.                   comp-output))
  530.       label (cdr label))))
  531.  
  532. ;; Output one opcode and its optional argument
  533. (defun comp-write-op (opcode &optional arg)
  534.   (cond
  535.    ((null arg)
  536.     (comp-byte-out opcode))
  537.    ((<= arg comp-max-1-byte-arg)
  538.     (comp-byte-out (+ opcode arg)))
  539.    ((<= arg comp-max-2-byte-arg)
  540.     ;; 2-byte instruction
  541.     (comp-byte-out (+ opcode 6))
  542.     (comp-byte-out arg))
  543.    ((<= arg comp-max-3-byte-arg)
  544.     ;; 3-byte instruction
  545.     (comp-byte-out (+ opcode 7))
  546.     (comp-byte-out (lsh arg -8))
  547.     (comp-byte-out (logand arg 0xff)))
  548.    (t
  549.     (comp-error "Opcode overflow!"))))
  550.  
  551. ;; Output one byte
  552. (defun comp-byte-out (byte)
  553.   (setq comp-output (cons (cons byte comp-output-pc) comp-output)
  554.     comp-output-pc (1+ comp-output-pc)))
  555.  
  556.  
  557. ;; Functions which compile non-standard functions (ie special-forms)
  558.  
  559. (put 'if 'compile-fun 'comp-compile-if)
  560. (defun comp-compile-if (form)
  561.   (comp-compile-form (nth 1 form))
  562.   (if (= (length form) 3)
  563.       (let*
  564.       ((end-label (comp-make-label)))
  565.     (comp-compile-jmp op-jnp end-label)
  566.     (comp-dec-stack)
  567.     (comp-compile-form (nth 2 form))
  568.     (comp-set-label end-label))
  569.     (let*
  570.     ((end-label (comp-make-label))
  571.      (else-label (comp-make-label)))
  572.       (comp-compile-jmp op-jn else-label)
  573.       (comp-dec-stack)
  574.       (comp-compile-form (nth 2 form))
  575.       (comp-compile-jmp op-jmp end-label)
  576.       (comp-set-label else-label)
  577.       (comp-dec-stack)
  578.       (comp-compile-body (nthcdr 3 form))
  579.       (comp-set-label end-label))))
  580.  
  581. (put 'when 'compile-fun 'comp-compile-when)
  582. (defun comp-compile-when (form)
  583.   (comp-compile-form (nth 1 form))
  584.   (let
  585.       ((end-label (comp-make-label)))
  586.     (comp-compile-jmp op-jnp end-label)
  587.     (comp-dec-stack)
  588.     (comp-compile-body (nthcdr 2 form))
  589.     (comp-set-label end-label)))
  590.  
  591. (put 'unless 'compile-fun 'comp-compile-unless)
  592. (defun comp-compile-unless (form)
  593.   (comp-compile-form (nth 1 form))
  594.   (let
  595.       ((end-label (comp-make-label)))
  596.     (comp-compile-jmp op-jtp end-label)
  597.     (comp-dec-stack)
  598.     (comp-compile-body (nthcdr 2 form))
  599.     (comp-set-label end-label)))
  600.  
  601. (put 'quote 'compile-fun 'comp-compile-quote)
  602. (defun comp-compile-quote (form)
  603.   (comp-compile-constant (car (cdr form))))
  604.  
  605. (put 'function 'compile-fun 'comp-compile-function)
  606. (defun comp-compile-function (form)
  607.   (setq form (car (cdr form)))
  608.   (if (symbolp form)
  609.       (comp-compile-constant form)
  610.     (comp-compile-constant (comp-compile-lambda form))))
  611.  
  612. (put 'while 'compile-fun 'comp-compile-while)
  613. (defun comp-compile-while (form)
  614.   (let*
  615.       ((tst-label (comp-make-label))
  616.        (end-label (comp-make-label)))
  617.     (comp-set-label tst-label)
  618.     (comp-compile-form (nth 1 form))
  619.     (comp-compile-jmp op-jnp end-label)
  620.     (comp-dec-stack)
  621.     (comp-compile-body (nthcdr 2 form))
  622.     (comp-write-op op-pop)
  623.     (comp-dec-stack)
  624.     (comp-compile-jmp op-jmp tst-label)
  625.     (comp-set-label end-label)
  626.     (comp-inc-stack)))
  627.  
  628. (put 'progn 'compile-fun 'comp-compile-progn)
  629. (defun comp-compile-progn (form)
  630.   (comp-compile-body (cdr form)))
  631.  
  632. (put 'prog1 'compile-fun 'comp-compile-prog1)
  633. (defun comp-compile-prog1 (form)
  634.   (comp-compile-form (nth 1 form))
  635.   (comp-compile-body (nthcdr 2 form))
  636.   (comp-write-op op-pop)
  637.   (comp-dec-stack))
  638.  
  639. (put 'prog2 'compile-fun 'comp-compile-prog2)
  640. (defun comp-compile-prog2 (form)
  641.   (comp-compile-form (nth 1 form))
  642.   (comp-write-op op-pop)
  643.   (comp-dec-stack)
  644.   (comp-compile-form (nth 2 form))
  645.   (comp-compile-body (nthcdr 3 form))
  646.   (comp-write-op op-pop)
  647.   (comp-dec-stack))
  648.  
  649. (put 'setq 'compile-fun 'comp-compile-setq)
  650. (defun comp-compile-setq (form)
  651.   (setq form (cdr form))
  652.   (while (and (consp form) (consp (cdr form)))
  653.     (comp-compile-form (car (cdr form)))
  654.     (unless (consp (nthcdr 2 form))
  655.       (comp-write-op op-dup)
  656.       (comp-inc-stack))
  657.     (comp-write-op op-vsetc (comp-add-constant (car form)))
  658.     (comp-dec-stack)
  659.     (setq form (nthcdr 2 form))))
  660.  
  661. (put 'set 'compile-fun 'comp-compile-set)
  662. (defun comp-compile-set (form)
  663.   (comp-compile-form (nth 2 form))
  664.   (comp-write-op op-dup)
  665.   (comp-inc-stack)
  666.   (comp-compile-form (nth 1 form))
  667.   (comp-write-op op-vset)
  668.   (comp-dec-stack 2))
  669.  
  670. (put 'fset 'compile-fun 'comp-compile-fset)
  671. (defun comp-compile-fset (form)
  672.   (comp-compile-form (nth 2 form))
  673.   (comp-write-op op-dup)
  674.   (comp-inc-stack)
  675.   (comp-compile-form (nth 1 form))
  676.   (comp-write-op op-fset)
  677.   (comp-dec-stack 2))
  678.  
  679. (put 'let* 'compile-fun 'comp-compile-let*)
  680. (defun comp-compile-let* (form)
  681.   (let
  682.       ((list (car (cdr form))))
  683.     (comp-write-op op-init-bind)
  684.     (while (consp list)
  685.       (cond
  686.     ((consp (car list))
  687.       (let
  688.           ((tmp (car list)))
  689.         (comp-compile-body (cdr tmp))
  690.         (comp-write-op op-bind (comp-add-constant (car tmp)))))
  691.     (t
  692.       (comp-write-op op-nil)
  693.       (comp-inc-stack)
  694.       (comp-write-op op-bind (comp-add-constant (car list)))))
  695.       (comp-dec-stack)
  696.       (setq list (cdr list)))
  697.     (comp-compile-body (nthcdr 2 form))
  698.     (comp-write-op op-unbind)))
  699.  
  700. (put 'let 'compile-fun 'comp-compile-let)
  701. (defun comp-compile-let (form)
  702.   (let
  703.       ((list (car (cdr form)))
  704.        (sym-stk nil))
  705.     (comp-write-op op-init-bind)
  706.     (while (consp list)
  707.       (cond
  708.     ((consp (car list))
  709.       (setq sym-stk (cons (car (car list)) sym-stk))
  710.       (comp-compile-body (cdr (car list))))
  711.     (t
  712.       (setq sym-stk (cons (car list) sym-stk))
  713.       (comp-write-op op-nil)
  714.       (comp-inc-stack)))
  715.       (setq list (cdr list)))
  716.     (while (consp sym-stk)
  717.       (comp-write-op op-bind (comp-add-constant (car sym-stk)))
  718.       (comp-dec-stack)
  719.       (setq sym-stk (cdr sym-stk)))
  720.     (comp-compile-body (nthcdr 2 form))
  721.     (comp-write-op op-unbind)))
  722.  
  723. (put 'defun 'compile-fun 'comp-compile-defun)
  724. (defun comp-compile-defun (form)
  725.   (comp-compile-constant (nth 1 form))
  726.   (comp-write-op op-dup)
  727.   (comp-inc-stack)
  728.   (comp-compile-constant (comp-compile-lambda (cons 'lambda (nthcdr 2 form))))
  729.   (comp-write-op op-swap)
  730.   (comp-write-op op-fset)
  731.   (comp-dec-stack 2))
  732.  
  733. (put 'defmacro 'compile-fun 'comp-compile-defmacro)
  734. (defun comp-compile-defmacro (form)
  735.   (comp-compile-constant (nth 1 form))
  736.   (comp-write-op op-dup)
  737.   (comp-inc-stack)
  738.   (comp-compile-constant (cons 'macro (comp-compile-lambda (cons 'lambda (nthcdr 2 form)))))
  739.   (comp-write-op op-swap)
  740.   (comp-write-op op-fset)
  741.   (comp-dec-stack 2))
  742.  
  743. (put 'cond 'compile-fun 'comp-compile-cond)
  744. (defun comp-compile-cond (form)
  745.   (let
  746.       ((end-label (comp-make-label)))
  747.     (setq form (cdr form))
  748.     (while (consp form)
  749.       (let
  750.       ((subl (car form))
  751.        (next-label (comp-make-label)))
  752.     (comp-compile-form (car subl))
  753.     (comp-dec-stack)
  754.     (cond
  755.       ((consp (cdr subl))
  756.         (comp-compile-jmp op-jn next-label)
  757.         (comp-compile-body (cdr subl))
  758.         (comp-dec-stack)
  759.         (comp-compile-jmp op-jmp end-label)
  760.         (comp-set-label next-label))
  761.       (t
  762.         (comp-compile-jmp op-jtp end-label)))
  763.     (setq form (cdr form))))
  764.     (comp-write-op op-nil)
  765.     (comp-inc-stack)
  766.     (comp-set-label end-label)))
  767.  
  768. (put 'or 'compile-fun 'comp-compile-or)
  769. (defun comp-compile-or (form)
  770.   (let
  771.       ((end-label (comp-make-label)))
  772.     (setq form (cdr form))
  773.     (while (consp form)
  774.       (comp-compile-form (car form))
  775.       (comp-dec-stack)
  776.       (when (cdr form)
  777.     (comp-compile-jmp op-jtp end-label))
  778.       (setq form (cdr form)))
  779.     (comp-inc-stack)
  780.     (comp-set-label end-label)))
  781.  
  782. (put 'and 'compile-fun 'comp-compile-and)
  783. (defun comp-compile-and (form)
  784.   (let
  785.       ((end-label (comp-make-label)))
  786.     (setq form (cdr form))
  787.     (while (consp form)
  788.       (comp-compile-form (car form))
  789.       (comp-dec-stack)
  790.       (when (cdr form)
  791.     (comp-compile-jmp op-jnp end-label))
  792.       (setq form (cdr form)))
  793.     (comp-inc-stack)
  794.     (comp-set-label end-label)))
  795.  
  796. (put 'catch 'compile-fun 'comp-compile-catch)
  797. (defun comp-compile-catch (form)
  798.   (comp-compile-constant (compile-form (cons 'progn (nthcdr 2 form))))
  799.   (comp-compile-constant (nth 1 form))
  800.   (comp-write-op op-catch-kludge)
  801.   (comp-dec-stack))
  802.  
  803. (put 'unwind-protect 'compile-fun 'comp-compile-unwind-pro)
  804. (defun comp-compile-unwind-pro (form)
  805.   (comp-compile-constant (compile-form (cons 'progn (nthcdr 2 form))))
  806.   (comp-write-op op-unwind-pro)
  807.   (comp-dec-stack)
  808.   (comp-compile-form (nth 1 form))
  809.   (comp-write-op op-un-unwind-pro))
  810.  
  811. (put 'error-protect 'compile-fun 'comp-compile-error-protect)
  812. (defun comp-compile-error-protect (form)
  813.   (let
  814.       ((i 0))
  815.     (setq form (cdr form))
  816.     (unless (consp form)
  817.       (comp-error "No FORM to `error-protect'" form))
  818.     (comp-compile-constant (compile-form (car form)))
  819.     (setq form (cdr form))
  820.     (while (consp form)
  821.       (let
  822.       ((handler (car form)))
  823.     (unless (consp handler)
  824.       (comp-error "Badly formed handler to `error-protect'" form))
  825.     (comp-compile-constant (list (car handler)
  826.                      (compile-form (cons 'progn
  827.                              (cdr handler)))))
  828.     (setq form (cdr form)
  829.           i (1+ i))))
  830.     (comp-compile-constant (1+ i))
  831.     (comp-write-op op-error-pro)
  832.     (comp-dec-stack i)))
  833.  
  834. (put 'list 'compile-fun 'comp-compile-list)
  835. (defun comp-compile-list (form)
  836.   (let
  837.       ((count 0))
  838.     (setq form (cdr form))
  839.     (while (consp form)
  840.       (comp-compile-form (car form))
  841.       (setq
  842.        count (1+ count)
  843.        form (cdr form)))
  844.     (comp-write-op op-list count)
  845.     (comp-dec-stack (1- count))))
  846.  
  847. (put 'with-buffer 'compile-fun 'comp-compile-with-buffer)
  848. (defun comp-compile-with-buffer (form)
  849.   (comp-compile-form (nth 1 form))
  850.   (comp-write-op op-swap-buffer)
  851.   (comp-compile-body (nthcdr 2 form))
  852.   (comp-write-op op-swap)
  853.   (comp-write-op op-swap-buffer)
  854.   (comp-write-op op-pop)
  855.   (comp-dec-stack))
  856.  
  857. (put 'with-window 'compile-fun 'comp-compile-with-window)
  858. (defun comp-compile-with-window (form)
  859.   (comp-compile-form (nth 1 form))
  860.   (comp-write-op op-swap-window)
  861.   (comp-compile-body (nthcdr 2 form))
  862.   (comp-write-op op-swap)
  863.   (comp-write-op op-swap-window)
  864.   (comp-write-op op-pop)
  865.   (comp-dec-stack))
  866.  
  867. (put '- 'compile-fun 'comp-compile-minus)
  868. (put '- 'compile-opcode op-minus-2)
  869. (defun comp-compile-minus (form)
  870.   (if (/= (length form) 2)
  871.       (comp-compile-binary-op form)
  872.     (comp-compile-form (car (cdr form)))
  873.     (comp-write-op op-negate)))
  874.  
  875. ;; Instruction with no arguments
  876. (defun comp-compile-0-args (form)
  877.   (comp-write-op (get (car form) 'compile-opcode) 0)
  878.   (comp-inc-stack))
  879.  
  880. ;; Instruction taking 1 arg on the stack
  881. (defun comp-compile-1-args (form)
  882.   (comp-compile-form (nth 1 form))
  883.   (comp-write-op (get (car form) 'compile-opcode) 0))
  884.  
  885. ;; Instruction taking 2 args on the stack
  886. (defun comp-compile-2-args (form)
  887.   (comp-compile-form (nth 1 form))
  888.   (comp-compile-form (nth 2 form))
  889.   (comp-write-op (get (car form) 'compile-opcode) 0)
  890.   (comp-dec-stack))
  891.  
  892. ;; Instruction taking 3 args on the stack
  893. (defun comp-compile-3-args (form)
  894.   (comp-compile-form (nth 1 form))
  895.   (comp-compile-form (nth 2 form))
  896.   (comp-compile-form (nth 3 form))
  897.   (comp-write-op (get (car form) 'compile-opcode) 0)
  898.   (comp-dec-stack 2))
  899.  
  900. ;; Compile a form `(OP ARG1 ARG2 ARG3 ...)' into as many two argument
  901. ;; instructions as needed (PUSH ARG1; PUSH ARG2; OP; PUSH ARG3; OP; ...)
  902. (defun comp-compile-binary-op (form)
  903.   (let
  904.       ((opcode (get (car form) 'compile-opcode)))
  905.     (setq form (cdr form))
  906.     (unless (>= (length form) 2)
  907.       (comp-error "Too few args to binary operator" form))
  908.     (comp-compile-form (car form))
  909.     (setq form (cdr form))
  910.     (while (consp form)
  911.       (comp-compile-form (car form))
  912.       (comp-write-op opcode)
  913.       (comp-dec-stack)
  914.       (setq form (cdr form)))))
  915.  
  916.  
  917. ;; Opcode properties for the generic instructions, in a progn for compiled
  918. ;; speed
  919.  
  920. (progn
  921.   (put 'cons 'compile-fun 'comp-compile-2-args)
  922.   (put 'cons 'compile-opcode op-cons)
  923.   (put 'car 'compile-fun 'comp-compile-1-args)
  924.   (put 'car 'compile-opcode op-car)
  925.   (put 'cdr 'compile-fun 'comp-compile-1-args)
  926.   (put 'cdr 'compile-opcode op-cdr)
  927.   (put 'rplaca 'compile-fun 'comp-compile-2-args)
  928.   (put 'rplaca 'compile-opcode op-rplaca)
  929.   (put 'rplacd 'compile-fun 'comp-compile-2-args)
  930.   (put 'rplacd 'compile-opcode op-rplacd)
  931.   (put 'nth 'compile-fun 'comp-compile-2-args)
  932.   (put 'nth 'compile-opcode op-nth)
  933.   (put 'nthcdr 'compile-fun 'comp-compile-2-args)
  934.   (put 'nthcdr 'compile-opcode op-nthcdr)
  935.   (put 'aset 'compile-fun 'comp-compile-3-args)
  936.   (put 'aset 'compile-opcode op-aset)
  937.   (put 'aref 'compile-fun 'comp-compile-2-args)
  938.   (put 'aref 'compile-opcode op-aref)
  939.   (put 'length 'compile-fun 'comp-compile-1-args)
  940.   (put 'length 'compile-opcode op-length)
  941.   (put 'eval 'compile-fun 'comp-compile-1-args)
  942.   (put 'eval 'compile-opcode op-eval)
  943.   (put '+ 'compile-fun 'comp-compile-binary-op)
  944.   (put '+ 'compile-opcode op-plus-2)
  945.   (put '* 'compile-fun 'comp-compile-binary-op)
  946.   (put '* 'compile-opcode op-product-2)
  947.   (put '/ 'compile-fun 'comp-compile-binary-op)
  948.   (put '/ 'compile-opcode op-divide-2)
  949.   (put '% 'compile-fun 'comp-compile-binary-op)
  950.   (put '% 'compile-opcode op-mod-2)
  951.   (put 'lognot 'compile-fun 'comp-compile-1-args)
  952.   (put 'lognot 'compile-opcode op-lognot)
  953.   (put 'not 'compile-fun 'comp-compile-1-args)
  954.   (put 'not 'compile-opcode op-not)
  955.   (put 'logior 'compile-fun 'comp-compile-binary-op)
  956.   (put 'logior 'compile-opcode op-logior-2)
  957.   (put 'logxor 'compile-fun 'comp-compile-binary-op)
  958.   (put 'logxor 'compile-opcode op-logxor-2)
  959.   (put 'logand 'compile-fun 'comp-compile-binary-op)
  960.   (put 'logand 'compile-opcode op-logand-2)
  961.   (put 'equal 'compile-fun 'comp-compile-2-args)
  962.   (put 'equal 'compile-opcode op-equal)
  963.   (put 'eq 'compile-fun 'comp-compile-2-args)
  964.   (put 'eq 'compile-opcode op-eq)
  965.   (put '= 'compile-fun 'comp-compile-2-args)
  966.   (put '= 'compile-opcode op-num-eq)
  967.   (put '/= 'compile-fun 'comp-compile-2-args)
  968.   (put '/= 'compile-opcode op-num-noteq)
  969.   (put '> 'compile-fun 'comp-compile-2-args)
  970.   (put '> 'compile-opcode op-gtthan)
  971.   (put '< 'compile-fun 'comp-compile-2-args)
  972.   (put '< 'compile-opcode op-ltthan)
  973.   (put '>= 'compile-fun 'comp-compile-2-args)
  974.   (put '>= 'compile-opcode op-gethan)
  975.   (put '<= 'compile-fun 'comp-compile-2-args)
  976.   (put '<= 'compile-opcode op-lethan)
  977.   (put '1+ 'compile-fun 'comp-compile-1-args)
  978.   (put '1+ 'compile-opcode op-inc)
  979.   (put '1- 'compile-fun 'comp-compile-1-args)
  980.   (put '1- 'compile-opcode op-dec)
  981.   (put 'lsh 'compile-fun 'comp-compile-2-args)
  982.   (put 'lsh 'compile-opcode op-lsh)
  983.   (put 'zerop 'compile-fun 'comp-compile-1-args)
  984.   (put 'zerop 'compile-opcode op-zerop)
  985.   (put 'null 'compile-fun 'comp-compile-1-args)
  986.   (put 'null 'compile-opcode op-null)
  987.   (put 'atom 'compile-fun 'comp-compile-1-args)
  988.   (put 'atom 'compile-opcode op-atom)
  989.   (put 'consp 'compile-fun 'comp-compile-1-args)
  990.   (put 'consp 'compile-opcode op-consp)
  991.   (put 'listp 'compile-fun 'comp-compile-1-args)
  992.   (put 'listp 'compile-opcode op-listp)
  993.   (put 'numberp 'compile-fun 'comp-compile-1-args)
  994.   (put 'numberp 'compile-opcode op-numberp)
  995.   (put 'stringp 'compile-fun 'comp-compile-1-args)
  996.   (put 'stringp 'compile-opcode op-stringp)
  997.   (put 'vectorp 'compile-fun 'comp-compile-1-args)
  998.   (put 'vectorp 'compile-opcode op-vectorp)
  999.   (put 'throw 'compile-fun 'comp-compile-2-args)
  1000.   (put 'throw 'compile-opcode op-throw)
  1001.   (put 'fboundp 'compile-fun 'comp-compile-1-args)
  1002.   (put 'fboundp 'compile-opcode op-fboundp)
  1003.   (put 'boundp 'compile-fun 'comp-compile-1-args)
  1004.   (put 'boundp 'compile-opcode op-boundp)
  1005.   (put 'symbolp 'compile-fun 'comp-compile-1-args)
  1006.   (put 'symbolp 'compile-opcode op-symbolp)
  1007.   (put 'get 'compile-fun 'comp-compile-2-args)
  1008.   (put 'get 'compile-opcode op-get)
  1009.   (put 'put 'compile-fun 'comp-compile-3-args)
  1010.   (put 'put 'compile-opcode op-put)
  1011.   (put 'signal 'compile-fun 'comp-compile-2-args)
  1012.   (put 'signal 'compile-opcode op-signal)
  1013.   (put 'return 'compile-fun 'comp-compile-1-args)
  1014.   (put 'return 'compile-opcode op-return)
  1015.   (put 'reverse 'compile-fun 'comp-compile-1-args) ; new 12/7/94
  1016.   (put 'reverse 'compile-opcode op-reverse)
  1017.   (put 'nreverse 'compile-fun 'comp-compile-1-args)
  1018.   (put 'nreverse 'compile-opcode op-nreverse)
  1019.   (put 'assoc 'compile-fun 'comp-compile-2-args)
  1020.   (put 'assoc 'compile-opcode op-assoc)
  1021.   (put 'assq 'compile-fun 'comp-compile-2-args)
  1022.   (put 'assq 'compile-opcode op-assq)
  1023.   (put 'rassoc 'compile-fun 'comp-compile-2-args)
  1024.   (put 'rassoc 'compile-opcode op-rassoc)
  1025.   (put 'rassq 'compile-fun 'comp-compile-2-args)
  1026.   (put 'rassq 'compile-opcode op-rassq)
  1027.   (put 'last 'compile-fun 'comp-compile-2-args)
  1028.   (put 'last 'compile-opcode op-last)
  1029.   (put 'mapcar 'compile-fun 'comp-compile-2-args)
  1030.   (put 'mapcar 'compile-opcode op-mapcar)
  1031.   (put 'mapc 'compile-fun 'comp-compile-2-args)
  1032.   (put 'mapc 'compile-opcode op-mapc)
  1033.   (put 'member 'compile-fun 'comp-compile-2-args)
  1034.   (put 'member 'compile-opcode op-member)
  1035.   (put 'memq 'compile-fun 'comp-compile-2-args)
  1036.   (put 'memq 'compile-opcode op-memq)
  1037.   (put 'delete 'compile-fun 'comp-compile-2-args)
  1038.   (put 'delete 'compile-opcode op-delete)
  1039.   (put 'delq 'compile-fun 'comp-compile-2-args)
  1040.   (put 'delq 'compile-opcode op-delq)
  1041.   (put 'delete-if 'compile-fun 'comp-compile-2-args)
  1042.   (put 'delete-if 'compile-opcode op-delete-if)
  1043.   (put 'delete-if-not 'compile-fun 'comp-compile-2-args)
  1044.   (put 'delete-if-not 'compile-opcode op-delete-if-not)
  1045.   (put 'copy-sequence 'compile-fun 'comp-compile-1-args)
  1046.   (put 'copy-sequence 'compile-opcode op-copy-sequence)
  1047.   (put 'sequencep 'compile-fun 'comp-compile-1-args)
  1048.   (put 'sequencep 'compile-opcode op-sequencep)
  1049.   (put 'functionp 'compile-fun 'comp-compile-1-args)
  1050.   (put 'functionp 'compile-opcode op-functionp)
  1051.   (put 'special-form-p 'compile-fun 'comp-compile-1-args)
  1052.   (put 'special-form-p 'compile-opcode op-special-form-p)
  1053.   (put 'subrp 'compile-fun 'comp-compile-1-args)
  1054.   (put 'subrp 'compile-opcode op-subrp)
  1055.   (put 'eql 'compile-fun 'comp-compile-2-args)
  1056.   (put 'eql 'compile-opcode op-eql)
  1057.  
  1058.   (put 'set-current-buffer 'compile-fun 'comp-compile-2-args)
  1059.   (put 'set-current-buffer 'compile-opcode op-set-current-buffer)
  1060.   (put 'current-buffer 'compile-fun 'comp-compile-1-args)
  1061.   (put 'current-buffer 'compile-opcode op-current-buffer)
  1062.   (put 'bufferp 'compile-fun 'comp-compile-1-args)
  1063.   (put 'bufferp 'compile-opcode op-bufferp)
  1064.   (put 'markp 'compile-fun 'comp-compile-1-args)
  1065.   (put 'markp 'compile-opcode op-markp)
  1066.   (put 'windowp 'compile-fun 'comp-compile-1-args)
  1067.   (put 'windowp 'compile-opcode op-windowp))
  1068.